home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASCALL / NEETVGA / RGB / FERN1B.PAS < prev    next >
Pascal/Delphi Source File  |  1993-02-13  |  4KB  |  115 lines
  1. {****************************************************************************}
  2. {***********************                              ***********************}
  3. {**                           R-G-B Demonstrator                           **}
  4. {****************************                    ****************************}
  5. {**                       Copyrighted February 12, 1993                    **}
  6. {**                       (C) To Authors                                   **}
  7. {**                             Fernando Padilla                           **}
  8. {**                             Stephen Markham                            **}
  9. {******************************                ******************************}
  10. {****************************************************************************}
  11.  
  12. uses
  13.      roger,crt;
  14. const
  15.      pause=15;
  16.      base=15;
  17.      top=63;
  18. type
  19.      RGB=(R,RRRG,RRG,RRRGG,RG,RRGGG,RGG,RGGG,G,GGGB,GGB,GGGBB,GB,GGBBB,GBB,GBBB,B,BBBR,BBR,BBBRR,BR,BBRRR,BRR,BRRR,W);
  20.  
  21. procedure updatergb(a,b,c,d:integer);
  22. begin
  23.      textcolor(1);
  24.      gotoxy(1,1);
  25.       write('Color:');
  26.       writeln(a:14);
  27.      gotoxy(1,3);
  28.       write('RED:');
  29.       writeln(b:16);
  30.      gotoxy(1,4);
  31.       write('GREEN:');
  32.       writeln(c:14);
  33.      gotoxy(1,5);
  34.       write('BLUE:');
  35.       writeln(d:15);
  36. end;
  37.  
  38.  
  39. Procedure saycolor(a,b,c,d:integer;  updat:boolean);
  40.   function inverse(a,b:integer):integer;
  41.   begin
  42.        inverse:=abs(a-b);
  43.   end;
  44. begin
  45.      PutColor(a,b,c,d);
  46.      PutColor(a+1,inverse(d,top),inverse(c,top),inverse(d,top));
  47.      if updat then UpdateRGB(a,b,c,d);
  48. end;
  49.  
  50.  
  51. procedure control(display:boolean);
  52. var
  53.      palette:rogerrgbpalette;
  54.      color:rgb;
  55.      stop:boolean;
  56.   Procedure FadeColor(c:RGB;  display:boolean;  var stop:boolean);
  57.   var
  58.        i:integer;
  59.     Procedure DoColor(c:RGB;  i:integer;  var display,stop:boolean);
  60.     Begin
  61.          if not stop then
  62.          begin
  63.               Case c of
  64.                    R: SayColor(0,i,0,0,display);
  65.                 RRRG: SayColor(0,i,i div 3,0,display);
  66.                  RRG: SayColor(0,i,i div 2,0,display);
  67.                RRRGG: SayColor(0,i,(i*2) div 3,0,display);
  68.                   RG: SayColor(0,i,i,0,display);
  69.                RRGGG: SayColor(0,(i*2) div 3,i,0,display);
  70.                  RGG: SayColor(0,i div 2,i,0,display);
  71.                 RGGG: SayColor(0,i div 3,i,0,display);
  72.                    G: SayColor(0,0,i,0,display);
  73.                 GGGB: SayColor(0,0,i,i div 3,display);
  74.                  GGB: SayColor(0,0,i,i div 2,display);
  75.                GGGBB: SayColor(0,0,i,(i*2) div 3,display);
  76.                   GB: SayColor(0,0,i,i,display);
  77.                GGBBB: SayColor(0,0,(i*2) div 3,i,display);
  78.                  GBB: SayColor(0,0,i div 2,i,display);
  79.                 GBBB: SayColor(0,0,i div 3,i,display);
  80.                    B: SayColor(0,0,0,i,display);
  81.                 BBBR: SayColor(0,i div 3,0,i,display);
  82.                  BBR: SayColor(0,i div 2,0,i,display);
  83.                BBBRR: SayColor(0,(i*2) div 3,0,i,display);
  84.                   BR: SayColor(0,i,0,i,display);
  85.                BBRRR: SayColor(0,i,0,(i*2) div 3,display);
  86.                  BRR: SayColor(0,i,0,i div 2,display);
  87.                 BRRR: SayColor(0,i,0,i div 3,display);
  88.                    W: SayColor(0,i,i,i,display);
  89.               end;
  90.               delay(pause);
  91.               stop:=keypressed;
  92.          end;
  93.     end;
  94.   Begin
  95.        if not stop then
  96.        begin
  97.             For i := base To top Do Docolor(c,i,display,stop);
  98.             For i := top DownTo base Do Docolor(c,i,display,stop);
  99.        end;
  100.   end;
  101. Begin
  102.      store(palette);
  103.      stop:=false;
  104.      Repeat
  105.        for color:=R to W do FadeColor(color,display,stop);
  106.      Until KeyPressed or stop;
  107.      Restore(palette);
  108. End;
  109.  
  110.  
  111. begin
  112.      clrscr;
  113.      window(30,11,51,17);
  114.      control(not(pos('false',paramstr(1))>0));
  115. end.